home *** CD-ROM | disk | FTP | other *** search
/ Amiga Plus 2000 #5 / Amiga Plus CD - 2000 - No. 5.iso / Tools / Dev / fpc / demos / sortdemo.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  2000-01-01  |  18.5 KB  |  642 lines
  1. PROGRAM SortDemo;
  2.  
  3. { Graphical demonstration of sorting algorithms (W. N~ker, 02/96) }
  4. { based on "Sortieren" of Purity #48 }
  5.  
  6. {
  7.     Translated to PCQ from Kick(Maxon) Pascal.
  8.     Updated the source to 2.0+.
  9.     Now uses GadTools for menus.
  10.     Added CloseWindowSafely.
  11.     Cleaned up the menuhandling.
  12.     Added LockWinSize and RestoreWin, now the
  13.     window will be locked on showtime.
  14.  
  15.     The German text was translated to English
  16.     by Andreas Neumann, thanks Andreas.
  17.     Jun 03 1998.
  18.  
  19.     Translated to FPC Pascal.
  20.     Removed CloseWindowSafely, have do add
  21.     that procedure to Intuition.
  22.     Fixed a bug, when you halt the show the
  23.     window stayed locked.
  24.     Aug 23 1998.
  25.  
  26.     Added MessageBox for report.
  27.     31 Jul 2000.
  28.  
  29.     nils.sjoholm@mailbox.swipnet.se
  30.  
  31.     One last remark, the heapsort can't be stoped
  32.     so you have to wait until it's finished.
  33. }
  34.  
  35. uses Exec, Intuition, Graphics, Utility, GadTools, vartags,msgbox;
  36.  
  37.  
  38.  
  39. CONST version : PChar = '$VER: SortDemo 1.3  (23-Aug-98)';
  40.  
  41.       nmax=2000;
  42.  
  43.       MinWinX = 80;
  44.       MinWiny = 80;
  45.  
  46.       w         : pWindow  = Nil;
  47.       s         : pScreen  = Nil;
  48.       MenuStrip : pMenu    = Nil;
  49.       vi        : Pointer  = Nil;
  50.     
  51.  
  52.       modenames : Array[0..7] of string[10] = (
  53.                                 'Heapsort',
  54.                                 'Shellsort',
  55.                                 'Pick out',
  56.                                 'Insert',
  57.                                 'Shakersort',
  58.                                 'Bubblesort',
  59.                                 'Quicksort',
  60.                                 'Mergesort');
  61.  
  62.       { The easiest way to use gadtoolsmenus in FPC is
  63.         to have them as const types. No need to cast
  64.         strings to PChar. That we have to use recordmembers
  65.         name is a pain.
  66.       }
  67.  
  68.       nm : array[0..21] of tNewMenu = (
  69.       (nm_Type: NM_TITLE; nm_Label: 'Demo';nm_CommKey: NIL; nm_Flags: 0; 
  70.        nm_MutualExclude: 0; nm_UserData: NIL),
  71.       (nm_Type: NM_ITEM;  nm_Label: 'Start';nm_CommKey: 'S'; nm_Flags: 0; 
  72.        nm_MutualExclude: 0; nm_UserData: NIL),
  73.       (nm_Type: NM_ITEM;  nm_Label: 'Stop';nm_CommKey: 'H'; nm_Flags: 0; 
  74.        nm_MutualExclude: 0; nm_UserData: NIL),
  75.  
  76.       { this will be a barlabel, have to set this one later }
  77.       (nm_Type: NM_ITEM;  nm_Label: NIL; nm_CommKey: NIL; nm_Flags: 0; 
  78.        nm_MutualExclude: 0; nm_UserData: NIL),
  79.  
  80.       (nm_Type: NM_ITEM;  nm_Label: 'Quit';  nm_CommKey: 'Q'; nm_Flags: 0; 
  81.        nm_MutualExclude: 0; nm_UserData: NIL),
  82.       (nm_Type: NM_TITLE; nm_Label: 'Algorithm'; nm_CommKey: NIL; nm_Flags: 0; 
  83.        nm_MutualExclude: 0; nm_UserData: NIL),
  84.       (nm_Type: NM_ITEM;  nm_Label: 'HeapSort'; nm_CommKey: '1'; nm_Flags: 
  85.        CHECKIT+CHECKED+MENUTOGGLE; nm_MutualExclude: 254; nm_UserData: NIL),
  86.       (nm_Type: NM_ITEM;  nm_Label: 'ShellSort'; nm_CommKey: '2'; nm_Flags: 
  87.        CHECKIT+MENUTOGGLE; nm_MutualExclude: 253; nm_UserData: NIL),
  88.       (nm_Type: NM_ITEM;  nm_Label: 'Pick out'; nm_CommKey: '3'; nm_Flags: 
  89.        CHECKIT+MENUTOGGLE; nm_MutualExclude: 251; nm_UserData: NIL),
  90.       (nm_Type: NM_ITEM;  nm_Label: 'Insert'; nm_CommKey: '4'; nm_Flags: 
  91.        CHECKIT+MENUTOGGLE; nm_MutualExclude: 247; nm_UserData: NIL),
  92.       (nm_Type: NM_ITEM;  nm_Label: 'ShakerSort'; nm_CommKey: '5'; nm_Flags: 
  93.        CHECKIT+MENUTOGGLE; nm_MutualExclude: 239; nm_UserData: NIL),
  94.       (nm_Type: NM_ITEM;  nm_Label: 'BubbleSort'; nm_CommKey: '6'; nm_Flags: 
  95.        CHECKIT+MENUTOGGLE; nm_MutualExclude: 223; nm_UserData: NIL),
  96.       (nm_Type: NM_ITEM;  nm_Label: 'QuickSort'; nm_CommKey: '7'; nm_Flags: 
  97.        CHECKIT+MENUTOGGLE; nm_MutualExclude: 191; nm_UserData: NIL),
  98.       (nm_Type: NM_ITEM;  nm_Label: 'MergeSort'; nm_CommKey: '8'; nm_Flags: 
  99.        CHECKIT+MENUTOGGLE; nm_MutualExclude: 127; nm_UserData: NIL),
  100.       (nm_Type: NM_TITLE; nm_Label: 'Preferences'; nm_CommKey: NIL; nm_Flags: 0; 
  101.        nm_MutualExclude: 0; nm_UserData: NIL),
  102.       (nm_Type: NM_ITEM;  nm_Label: 'Data'; nm_CommKey: NIL; nm_Flags: 0; 
  103.        nm_MutualExclude: 0; nm_UserData: NIL),
  104.       (nm_Type: NM_SUB;   nm_Label: 'Random'; nm_CommKey: 'R'; nm_Flags: 
  105.        CHECKIT+CHECKED+MENUTOGGLE; nm_MutualExclude: 2; nm_UserData: NIL),
  106.       (nm_Type: NM_SUB;   nm_Label: 'Malicious'; nm_CommKey: 'M'; nm_Flags: 
  107.        CHECKIT+MENUTOGGLE; nm_MutualExclude: 1; nm_UserData: NIL),
  108.       (nm_Type: NM_ITEM;  nm_Label: 'Diagram'; nm_CommKey: NIL; nm_Flags: 0; 
  109.        nm_MutualExclude: 0; nm_UserData: NIL),
  110.       (nm_Type: NM_SUB;   nm_Label: 'Needles'; nm_CommKey: 'N'; nm_Flags: 
  111.        CHECKIT+CHECKED+MENUTOGGLE; nm_MutualExclude: 2; nm_UserData: NIL),
  112.       (nm_Type: NM_SUB;   nm_Label: 'Dots'; nm_CommKey: 'D'; nm_Flags: 
  113.        CHECKIT+MENUTOGGLE; nm_MutualExclude: 1; nm_UserData: NIL),
  114.       (nm_Type: NM_END;   nm_Label: NIL; nm_CommKey: NIL; nm_Flags: 
  115.        0;nm_MutualExclude:0;nm_UserData:NIL));
  116.  
  117.  
  118. VAR sort: ARRAY[1..nmax] OF Real;
  119.     sort2: ARRAY[1..nmax] OF Real;  { for dumb Mergesort %-( }
  120.     num,range,modus : Integer;
  121.     rndom,needles   : Boolean;
  122.     Rast            : pRastPort;
  123.     QuitStopDie     : Boolean;
  124.     Msg             : pMessage;
  125.     wintitle        : string[80];
  126.     scrtitle        : string[80];
  127.  
  128. Procedure CleanUp(s : string; err : Integer);
  129. begin
  130.     if assigned(MenuStrip) then begin
  131.        ClearMenuStrip(w);
  132.        FreeMenus(MenuStrip);
  133.     end;
  134.     if assigned(vi) then FreeVisualInfo(vi);
  135.     if assigned(w) then CloseWindow(w);
  136.     if assigned(GfxBase) then CloseLibrary(GfxBase);
  137.     if assigned(GadToolsBase) then CloseLibrary(GadToolsBase);
  138.     if s <> '' then MessageBox('SortDemo Report',s,'OK');
  139.     Halt(err);
  140. end;
  141.  
  142. Procedure RestoreWin;
  143. var
  144.    dummy : Boolean;
  145. begin
  146.    dummy := WindowLimits(w,MinWinX,MinWinY,-1,-1);
  147. end;
  148.  
  149. Procedure LockWinSize(x,y,x2,y2 : Integer);
  150. var
  151.    dummy : Boolean;
  152. begin
  153.    dummy := WindowLimits(w,x,y,x2,y2);
  154. end;
  155.  
  156. FUNCTION cancel: Boolean;
  157. { checked while sorting }
  158. VAR m,i,s: Integer;
  159.     result : boolean;
  160.     IM : pIntuiMessage;
  161. BEGIN
  162.   result := False;
  163.   IM := pIntuiMessage(GetMsg(w^.UserPort));
  164.   IF IM<>Nil THEN BEGIN
  165.     IF IM^.IClass=IDCMP_CLOSEWINDOW THEN
  166.       result := True;   { Close-Gadget }
  167.     IF IM^.IClass=IDCMP_MENUPICK THEN BEGIN
  168.       m := IM^.Code AND $1F;
  169.       i := (IM^.Code SHR 5) AND $3F;
  170.       s := (IM^.Code SHR 11) AND $1F;
  171.       IF (m=0) AND (i=1) THEN  result := True;  { Menu item "Stop" }
  172.     END;
  173.     ReplyMsg(pMessage(Msg));
  174.   END;
  175.   cancel := result;
  176. END;
  177.  
  178.  
  179. PROCEDURE showstack(size: Integer);
  180. { little diagram showing the depth of Quicksort's recursion :-) }
  181. BEGIN
  182.   SetAPen(Rast,2); IF size>0 THEN RectFill(Rast,0,0,3,size-1);
  183.   SetAPen(Rast,0); RectFill(Rast,0,size,3,size);
  184. END;
  185.  
  186.  
  187. PROCEDURE setpixel(i: Integer);
  188. BEGIN
  189.   SetAPen(Rast,1);
  190.   IF needles THEN BEGIN
  191.     Move(Rast,i,range); Draw(Rast,i,Round((1-sort[i])*range));
  192.   END ELSE
  193.     IF WritePixel(Rast,i,Round((1-sort[i])*range))=0 THEN;
  194. END;
  195.  
  196. PROCEDURE clearpixel(i: Integer);
  197. BEGIN
  198.   SetAPen(Rast,0);
  199.   IF needles THEN BEGIN
  200.     Move(Rast,i,range); Draw(Rast,i,Round((1-sort[i])*range));
  201.   END ELSE
  202.     IF WritePixel(Rast,i,Round((1-sort[i])*range))=0 THEN;
  203. END;
  204.  
  205. procedure Exchange(var first,second : real);
  206. var
  207.   temp : real;
  208. begin
  209.   temp := first;
  210.   first := second;
  211.   second := temp;
  212. end;
  213.  
  214. PROCEDURE swapit(i,j: integer);
  215. BEGIN
  216.   clearpixel(i); clearpixel(j);
  217.   Exchange(sort[i],sort[j]);
  218.   setpixel(i); setpixel(j);
  219. END;
  220.  
  221. FUNCTION descending(i,j: Integer): Boolean;
  222. BEGIN
  223.   descending := sort[i]>sort[j];
  224. END;
  225.  
  226. Function IntToStr (I : Longint) : String;
  227.  
  228.      Var S : String;
  229.  
  230.      begin
  231.       Str (I,S);
  232.       IntToStr:=S;
  233.      end;
  234.  
  235.  
  236. PROCEDURE settitles(time: Longint);
  237. VAR
  238.   s : string[80];
  239. BEGIN
  240.   s := modenames[modus];
  241.   IF time=0 THEN
  242.     wintitle := s + ' running ...'
  243.   ELSE IF time < 0 then
  244.     wintitle := '<- ' + IntToStr(num) + ' Data ->'
  245.   ELSE
  246.     wintitle := IntToStr(time) + ' Seconds';
  247.   scrtitle := strpas(@version[6]) + ' - ' + s;
  248.   wintitle := wintitle + #0;
  249.   scrtitle := scrtitle + #0;
  250.   SetWindowTitles(w,@wintitle[1],@scrtitle[1]);
  251. END;
  252.  
  253. PROCEDURE refresh;
  254. { react on new size of window/init data }
  255. VAR i: Integer;
  256. BEGIN
  257.   num := w^.GZZWidth; IF num>nmax THEN num := nmax;
  258.   range := w^.GZZHeight;
  259.   settitles(-1);
  260.   SetRast(Rast,0);    { clear screen }
  261.   FOR i := 1 TO num DO BEGIN
  262.     IF rndom THEN sort[i] := Random  { produces 0..1 }
  263.       ELSE sort[i] := (num-i)/num;
  264.     setpixel(i);
  265.   END;
  266. END;
  267.  
  268. { *#*#*#*#*#*#*#*#*#*#*#*#*#*#*#*#*#*#*#*#*#*#*#*#*#*#*#*#*#*#*#*#*#*#*#* }
  269. { *#*#*#*#*#*#*#*#*#*#*# The sorting algorithms! #*#*#*#*#*#*#*#*#*#*#*#* }
  270. { *#*#*#*#*#*#*#*#*#*#*#*#*#*#*#*#*#*#*#*#*#*#*#*#*#*#*#*#*#*#*#*#*#*#*#* }
  271.  
  272. PROCEDURE bubblesort;
  273. { like the head of a beer, reaaal slow and easy-going }
  274. VAR i,j,max: Integer;
  275. BEGIN
  276.   LockWinSize(w^.Width,w^.Height,w^.Width,w^.Height);
  277.   max := num;
  278.   REPEAT
  279.     j := 1;
  280.     FOR i := 1 TO max-1 DO
  281.       IF descending(i,i+1) THEN BEGIN
  282.         swapit(i,i+1); j := i;
  283.       END;
  284.     max := j;
  285.   UNTIL (max=1) OR cancel;
  286.   RestoreWin;
  287. END;
  288.  
  289. PROCEDURE shakersort;
  290. { interesting variant, but bubblesort still remains hopelessness }
  291. { (because it only compares and swaps immediate adjacent units)  }
  292. VAR i,j,min,max: Integer;
  293. BEGIN
  294.   LockWinSize(w^.Width,w^.Height,w^.Width,w^.Height);
  295.   min := 1;
  296.   max := num;
  297.   REPEAT
  298.     j := min;
  299.     FOR i := min TO max-1 DO
  300.       IF descending(i,i+1) THEN BEGIN
  301.         swapit(i,i+1); j := i;
  302.       END;
  303.     max := j;
  304.     j := max;
  305.     FOR i := max DOWNTO min+1 DO
  306.       IF descending(i-1,i) THEN BEGIN
  307.         swapit(i,i-1); j := i;
  308.       END;
  309.     min := j;
  310.   UNTIL (max=min) OR cancel;
  311.   RestoreWin;
  312. END;
  313.  
  314. PROCEDURE e_sort;
  315. { Insert: a pretty human strategy }
  316. VAR i,j: Integer;
  317. BEGIN
  318.   LockWinSize(w^.Width,w^.Height,w^.Width,w^.Height);
  319.   FOR i := 2 TO num DO BEGIN
  320.     j := i;
  321.     WHILE j>1 DO
  322.       IF descending(j-1,j) THEN BEGIN
  323.         swapit(j-1,j); Dec(j);
  324.       END ELSE
  325.         j := 1;
  326.     IF cancel THEN begin
  327.         RestoreWin;
  328.         Exit;
  329.     end;
  330.   END;
  331.   RestoreWin;
  332. END;
  333.  
  334. PROCEDURE a_sort;
  335. { Pick out: Preparation is one half of a life }
  336. { Take a look at the ridiculous low percentage of successful comparisions:  }
  337. { Although there are only n swaps, there are n^2/2 comparisions!            }
  338. { Both is a record, one in a good sense, the other one in a bad sense.      }
  339.  
  340. VAR i,j,minpos: Integer;
  341.     min: Real;
  342. BEGIN
  343.   LockWinSize(w^.Width,w^.Height,w^.Width,w^.Height);
  344.   FOR i := 1 TO num-1 DO BEGIN
  345.     minpos := i; min := sort[i];
  346.     FOR j := i+1 TO num DO
  347.       IF descending(minpos,j) THEN
  348.         minpos := j;
  349.     IF minpos<>i THEN swapit(i,minpos);
  350.     IF cancel THEN begin
  351.         RestoreWin;
  352.         Exit;
  353.     end;
  354.   END;
  355.   RestoreWin;
  356. END;
  357.  
  358. PROCEDURE shellsort;
  359. { brilliant extension of E-Sort, stunning improvement of efficience }
  360. VAR i,j,gap: Integer;
  361. BEGIN
  362.   LockWinSize(w^.Width,w^.Height,w^.Width,w^.Height);
  363.   gap := num DIV 2;
  364.   REPEAT
  365.     FOR i := 1+gap TO num DO BEGIN
  366.       j := i;
  367.       WHILE j>gap DO
  368.         IF descending(j-gap,j) THEN BEGIN
  369.           swapit(j,j-gap); j := j-gap;
  370.         END ELSE
  371.           j := 1;
  372.       IF cancel THEN begin
  373.           RestoreWin;
  374.           Exit;
  375.       end;
  376.     END;
  377.     gap := gap DIV 2;
  378.   UNTIL gap=0;
  379.   RestoreWin;
  380. END;
  381.  
  382. PROCEDURE seepaway(i,max: Integer);
  383. { belongs to heapsort }
  384. VAR j: Integer;
  385. BEGIN
  386.   j := 2*i;
  387.   WHILE j<=max DO BEGIN
  388.     IF j<max THEN IF descending(j+1,j) THEN
  389.       Inc(j);
  390.     IF descending(j,i) THEN BEGIN
  391.       swapit(j,i);
  392.       i := j; j := 2*i;
  393.     END ELSE
  394.       j := max+1; { cancels }
  395.   END;
  396. END;
  397.  
  398. PROCEDURE heapsort;
  399. { this genius rules over the chaos: it's the best algorithm, I know about    }
  400. { The only disadvantage compared with shellsort: it's not easy to understand }
  401. { and impossible to know it by heart. }
  402. VAR i,j: Integer;
  403. BEGIN
  404.   LockWinSize(w^.Width,w^.Height,w^.Width,w^.Height);
  405.   i := num DIV 2 + 1;
  406.   j := num;
  407.   WHILE i>1 DO BEGIN
  408.     Dec(i); seepaway(i,j);
  409.   END;
  410.   WHILE j>1 DO BEGIN
  411.     swapit(i,j);
  412.     Dec(j); seepaway(i,j);
  413.   END;
  414.   RestoreWin;
  415. END;
  416.  
  417. PROCEDURE quicksort;
  418. { "divide and rule": a classic, but recursive  >>-( }
  419. { In this demonstration it is faster than heapsort, but does considerable }
  420. { more unsuccessful comparisions. }
  421. VAR stack: ARRAY[1..100] OF RECORD li,re: Integer; END;
  422.     sp,l,r,m,i,j: Integer;
  423. BEGIN
  424.   LockWinSize(w^.Width,w^.Height,w^.Width,w^.Height);
  425.   sp := 1; stack[1].li := 1; stack[1].re := num;
  426.   REPEAT
  427.     l := stack[sp].li; r := stack[sp].re; Dec(sp);
  428.     showstack(sp);
  429.     m := (l+r) DIV 2;
  430.     i := l; j := r;
  431.     REPEAT
  432.       WHILE descending(m,i) DO Inc(i);
  433.       WHILE descending(j,m) DO Dec(j);
  434.       IF j>i THEN swapit(i,j);
  435.       IF m=i THEN m := j ELSE IF m=j THEN m := i; { ahem ... }
  436.       { This "Following" of the reference data is only required because  }
  437.       { I stubborn call the comparision function, and this one only gets }
  438.       { indices on the values which have to be compared. }
  439.     UNTIL i>=j;
  440.     IF i>l THEN BEGIN
  441.       Inc(sp); stack[sp].li := l; stack[sp].re := i; END;
  442.     IF i+1<r THEN BEGIN
  443.       Inc(sp); stack[sp].li := i+1; stack[sp].re := r; END;
  444.   UNTIL (sp=0) OR cancel;
  445.   RestoreWin;
  446. END;
  447.  
  448. PROCEDURE mergesort;
  449. { *the* algorithm for lists with pointers on it, for arrays rather }
  450. { inacceptable. The non.recursive implementation came out pretty more }
  451. { complicated than the one for quicksort, as quicksort first does }
  452. { something and then recurses; with mergesort it is the other way round. }
  453. VAR stack: ARRAY[1..100] OF RECORD li,re,mi: Integer; END;
  454.     sp,l,r,i,j,k,m: Integer;
  455. BEGIN
  456.   LockWinSize(w^.Width,w^.Height,w^.Width,w^.Height);
  457.   sp := 1; stack[1].li := 1; stack[1].re := num; stack[1].mi := 0;
  458.   REPEAT
  459.     l := stack[sp].li; r := stack[sp].re; m := stack[sp].mi; Dec(sp);
  460.     showstack(sp);
  461.     IF m>0 THEN BEGIN { put two halfs together }
  462.       { Unfortunately it is only possible in an efficient way by using }
  463.       { extra memory; mergesort really is something for lists with }
  464.       { pointers originally ... }
  465.       FOR i := m DOWNTO l do sort2[i] := sort[i];  i := l;
  466.       FOR j := m+1 TO r DO sort2[r+m+1-j] := sort[j];  j := r;
  467.       FOR k := l TO r DO BEGIN
  468.         clearpixel(k);
  469.         IF sort2[i]<sort2[j] THEN BEGIN
  470.           sort[k] := sort2[i]; Inc(i);
  471.         END ELSE BEGIN
  472.           sort[k] := sort2[j]; Dec(j);
  473.         END;
  474.         setpixel(k);
  475.       END;
  476.     END ELSE IF l<r THEN BEGIN
  477.       { create two halfs and the order to put them together }
  478.       m := (l+r) DIV 2;
  479.       Inc(sp); stack[sp].li := l; stack[sp].mi := m; stack[sp].re := r;
  480.       Inc(sp); stack[sp].li := m+1; stack[sp].mi := 0; stack[sp].re := r;
  481.       Inc(sp); stack[sp].li := l; stack[sp].mi := 0; stack[sp].re := m;
  482.     END;
  483.   UNTIL (sp=0) OR cancel;
  484.   RestoreWin;
  485. END;
  486.  
  487.  
  488. Procedure OpenEverything;
  489. begin
  490.     GadToolsBase := OpenLibrary(GADTOOLSNAME,37);
  491.     if GadToolsBase = nil then CleanUp('Can''t open gadtools.library',20);
  492.     GfxBase := OpenLibrary(GRAPHICSNAME,37);
  493.     if GfxBase = nil then CleanUp('Can''t open graphics.library',20);
  494.  
  495.     s := LockPubScreen(nil);
  496.     if s = nil then CleanUp('Could not lock pubscreen',10);
  497.  
  498.     vi := GetVisualInfoA(s, NIL);
  499.     if vi = nil then CleanUp('No visual info',10);
  500.  
  501.     w := OpenWindowTagList(NIL, TAGS(
  502.                 WA_IDCMP,         IDCMP_CLOSEWINDOW or IDCMP_MENUPICK or 
  503. IDCMP_NEWSIZE,
  504.                 WA_Left,          0,
  505.                 WA_Top,           s^.BarHeight+1,
  506.                 WA_Width,         224,
  507.                 WA_Height,        s^.Height-(s^.BarHeight-1),
  508.                 WA_MinWidth,      MinWinX,
  509.                 WA_MinHeight,     MinWinY,
  510.                 WA_MaxWidth,      -1,
  511.                 WA_MaxHeight,     -1,
  512.                 WA_DepthGadget,   ltrue,
  513.                 WA_DragBar,       ltrue,
  514.                 WA_CloseGadget,   ltrue,
  515.                 WA_SizeGadget,    ltrue,
  516.                 WA_Activate,      ltrue,
  517.                 WA_SizeBRight,    ltrue,
  518.                 WA_GimmeZeroZero, ltrue,
  519.                 WA_PubScreen,     longint(s),
  520.                 TAG_END));
  521.     
  522.     IF w=NIL THEN CleanUp('Could not open window',20);
  523.  
  524.     Rast := w^.RPort;
  525.  
  526.     { Here we set the barlabel }
  527.     nm[3].nm_Label := PChar(NM_BARLABEL);
  528.  
  529.     if pExecBase(_ExecBase)^.LibNode.Lib_Version >= 39 then begin
  530.         MenuStrip := CreateMenusA(@nm,TAGS(
  531.                      GTMN_FrontPen, 1, TAG_END));
  532.     end else MenuStrip := CreateMenusA(@nm,NIL);
  533.  
  534.     if MenuStrip = nil then CleanUp('Could not open Menus',10);
  535.     if LayoutMenusA(MenuStrip,vi,NIL)=false then
  536.         CleanUp('Could not layout Menus',10);
  537.  
  538.     if SetMenuStrip(w, MenuStrip) = false then
  539.         CleanUp('Could not set the Menus',10);
  540.  
  541. end;
  542.  
  543. PROCEDURE ProcessIDCMP;
  544. VAR
  545.     IMessage    : tIntuiMessage;
  546.     IPtr    : pIntuiMessage;
  547.  
  548.     Procedure ProcessMenu;
  549.     var
  550.     MenuNumber  : Integer;
  551.     ItemNumber  : Integer;
  552.     SubItemNumber   : Integer;
  553.     t0,t1,l         : Longint;
  554.  
  555.     begin
  556.     if IMessage.Code = MENUNULL then
  557.         Exit;
  558.  
  559.     MenuNumber := MenuNum(IMessage.Code);
  560.     ItemNumber := ItemNum(IMessage.Code);
  561.     SubItemNumber := SubNum(IMessage.Code);
  562.  
  563.     case MenuNumber of
  564.       0 : begin
  565.           case ItemNumber of
  566.              0 : begin
  567.                    refresh;
  568.                    settitles(0);
  569.                    CurrentTime(t0,l);
  570.                    CASE modus OF
  571.                      0: heapsort;
  572.                      1: shellsort;
  573.                      2: a_sort;
  574.                      3: e_sort;
  575.                      4: shakersort;
  576.                      5: bubblesort;
  577.                      6: quicksort;
  578.                      7: mergesort;
  579.                    END;
  580.                    CurrentTime(t1,l);
  581.                    settitles(t1-t0);
  582.                  end;
  583.              3 : QuitStopDie := True;
  584.           end;
  585.           end;
  586.       1 : begin
  587.           case ItemNumber of
  588.               0..7 : modus := ItemNumber;
  589.           end;
  590.           settitles(-1);
  591.           end;
  592.       2 : begin
  593.           case ItemNumber of
  594.              0 : begin
  595.                  case SubItemNumber of
  596.                     0 : if not rndom then rndom := true;
  597.                     1 : if rndom then rndom := false;
  598.                  end;
  599.                  end;
  600.              1 : begin
  601.                  case SubItemNumber of
  602.                     0 : if not needles then needles := true;
  603.                     1 : if needles then needles := false;
  604.                  end;
  605.                  end;
  606.           end;
  607.           end;
  608.     end;
  609.     end;
  610.  
  611. begin
  612.     IPtr := pIntuiMessage(Msg);
  613.     IMessage := IPtr^;
  614.     ReplyMsg(Msg);
  615.  
  616.     case IMessage.IClass of
  617.       IDCMP_MENUPICK    : ProcessMenu;
  618.       IDCMP_NEWSIZE     : refresh;
  619.       IDCMP_CLOSEWINDOW : QuitStopDie := True;
  620.     end;
  621. end;
  622.  
  623.  
  624.  
  625. begin
  626.    OpenEverything;
  627.    QuitStopDie := False;
  628.    modus := 0;
  629.    needles := true;
  630.    rndom := true;
  631.    refresh;
  632.    repeat
  633.    Msg := WaitPort(w^.UserPort);
  634.    Msg := GetMsg(w^.UserPort);
  635.        ProcessIDCMP;
  636.    until QuitStopDie;
  637.    CleanUp('',0);
  638. end.
  639.  
  640.  
  641.  
  642.